home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d27 / tp5250ap.arc / EM5250IO.PAS next >
Pascal/Delphi Source File  |  1991-12-04  |  64KB  |  1,685 lines
  1. unit em5250io; {Full Screen Manager and 5250 Emulator Interface Routines}
  2. {$V-}
  3.  
  4. Interface
  5. Uses dos,crt,printer;
  6.  
  7. Type
  8.   indicatorarray = array[1..100] of char;
  9.   cmdarray       = array[1..12]  of char;
  10.   rtnstring      = string[80];
  11.   formatpointer  = ^formatswork;
  12.   fpointer       = ^screenfields;
  13.   fmtnamestring  =  string[8];
  14.   filenamestring =  string[12];
  15.   formatswork = record             {format header information Array record}
  16.    wformatname:          string[8];{format name}
  17.    wscreenrow:           integer;  {starting row of format}
  18.    wscreencol:           integer;  {starting column of format}
  19.    wbkintcolor:          integer;  {initial background color}
  20.    wtxintcolor:          integer;  {initial text color}
  21.    wclrline:             integer;  {number of lines on screen to clear}
  22.                                    {from first used line of this format}
  23.    wputovr:              integer;  {indicator-rewrite panel without constants}
  24.                                    {and without erasing input only type fields}
  25.    weraseinp:            integer;  {indicator-erase input only type fields on}
  26.                                    {if putovr indicator is on (1)}
  27.    whelpname:            string[8];{Name of Help Format For This Format}
  28.    wcommandkeymask:      cmdarray; {Valid Commandkeys This FMT}
  29.    nextformat:           formatpointer;
  30.    firstconstant:        fpointer;
  31.    firstfield:           fpointer;
  32.   end;
  33.  
  34.  screenfields = record             {field description on heap record}
  35.   screenrow:            integer;   {row starting location of field}
  36.   screencol:            integer;   {column starting location of field}
  37.   fieldlen:             byte;      {Length Of Field Including Decimals If Any}
  38.   fill1:                byte;
  39.   fielddec:             byte;      {Number Of Decimal Positions In Field}
  40.   lowercas:             char;      {Allow Lower Case If None Blank}
  41.   datatype:             char;      {C=Character or String,N=Integer or Real}
  42.   iotype:               char;      {I=Input Only, O=Output Only, B=Both}
  43.   fieldnam:             string[8];
  44.   fmtname:              string[8]; {Name Of This Format(Screen Panel)}
  45.   screenname:           string[8]; {Name Of File Containing Panel Descriptions}
  46.   bkcolor:              byte;      {Background color}
  47.   position:             byte;
  48.   txcolor:              byte;      {Text Display Color}
  49.   protect:              byte;
  50.   rvrsimg:              byte;      {Indicator 01-99 if 1 Colors Are Reversed}
  51.   blink:                byte;      {Field Will Blink If Indicator Is On}
  52.   errorind:             byte;      {Indicator 01-99 if 1 Error Msg. Displayed}
  53.                                    {error message stored in constandata}
  54.   fill4:                byte;
  55.   constantdata:         string[80];
  56.   nextfield:            fpointer;
  57.   prvfield:             fpointer;
  58.   fieldoffset:          word;
  59.  end;
  60.  
  61. Const
  62.  entercode:         byte = $68;    {5250 enter key scan code}
  63.  systemrequestcode: byte = $7C;    {5250 System Request Scan Code}
  64.  commandcode:       byte = $6F;    {5250 CMD key. PC F2 key}
  65.  commandkey:        char = ' ';    {commandkey indicator}
  66.  block38:           char = ' ';    {move fields without field exit if not ' '}
  67.  fieldexitcode:     byte = $2D;    {5250 Field Exit Key PC Enter Key}
  68.  _In: indicatorarray =
  69.  ('0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0',
  70.   '0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0',
  71.   '0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0',
  72.   '0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0',
  73.   '0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0');
  74.  
  75. procedure seton(indicatornum:shortint);
  76. procedure setof(indicatornum:shortint);
  77. procedure resetind;
  78. procedure openscreenfile(var firstscreenseg,firstscreenofs:word;
  79.                              screenfilename:filenamestring);
  80. procedure screenio(usezfmtname: fmtnamestring);
  81. procedure writescreen(usefmtname: fmtnamestring);
  82. procedure readscreen(usefmtname: fmtnamestring);
  83. procedure checkinputinhibit;
  84. procedure read38(idrow,idcol,idlen:shortint);
  85. procedure sendfieldexit(sendendoffield: byte);
  86. procedure sendcommandkey(commandkeyx:char);
  87. procedure write38(idrow,idcol,idlen:shortint);
  88. procedure copyscreen(startrow,startcolumn,endrow,endcolumn:shortint);
  89. procedure check38(startrow,startcol,lengthx:shortint; var rtnformat:rtnstring);
  90. procedure autohotkey(hotkeyrow,hotkeycolumn: shortint; hotkeychar:char);
  91.  
  92. Implementation
  93.  
  94. Const
  95.  inzscreen:             char    = ' ';   {screen specs read from disk flag}
  96.  displayadaptersegment: word    = $B000; {color display segment address}
  97.  helplevel:             shortint= 0;     {Depth Of Help Screens Displayed}
  98.  bottomlinebackground:  shortint= 0;
  99.  bottomlineforeground:  shortint= 0;
  100.  backgroundcolortable:  array[1..16] of byte =($00,$10,$20,$30,$40,$50,$60,$70,
  101.                                               $00,$10,$20,$30,$40,$50,$60,$70);
  102.  textcolortable:        array[1..16] of byte =($00,$01,$02,$03,$04,$05,$06,$07,
  103.                                               $08,$09,$0A,$0B,$0C,$0D,$0E,$0F);
  104.   errormsg:             array[1..11] of string[64] =  {keyboard error messages}
  105.     ('Attempt To Advance Cursor Off The Screen. Use Tab or Field Exit',
  106.      'Cursor Advanced Past Start/End Of Field. Use Tab or Field Exit',
  107.      'Unidentified Character Entered. Re-enter.',
  108.      'Attempt To Enter Info Past End Of Field. Use Tab or Field Exit',
  109.      'Field Requires Numbers Only, Other Characters Not Allowed',
  110.      'Field Is Full. Insertion Cannot Be Performed',
  111.      'No HELP Screen Is Defined For This Screen',
  112.      'Command Key Is Not Valid For This Format',
  113.      'Numeric Field Conversion Error',
  114.      'Invalid Command Key Pressed. Command Key Is Cancelled',
  115.      'Requested Format Was Not Found. Program Aborted. ');
  116.  firsthelp:     integer=0;
  117.  secondhelp:    integer=0;
  118.  thirdhelp:     integer=0;
  119.  fourthhelp:    integer=0;
  120.  fifthhelp:     integer=0;
  121.  sixthhelp:     integer=0;
  122.  format1:       integer=0;
  123.  format2:       integer=0;
  124.  fieldpointer:  fpointer=nil;
  125.  currentformat: formatpointer=nil;
  126.  charoutbuffer:        string[80]=' ';  {output data field character buffer}
  127.  inpbuffer:            string[80]=' ';  {input field keyboard buffer}
  128.  previousformatname:   string[8] =' ';  {name of last panel read from disk}
  129.  zformatname:          string[8] =' ';  {format name holding variable}
  130.  inputbufferlength:    byte = $00;  {length of current field as a byte}
  131.  charin:               char = ' ';  {current character from keyboard}
  132.  insertmodeflag:       char = ' ';  {Flag For F3 Press }
  133.  inputfieldonlyflag:   char = ' ';  {Eraseinput Key Screenwrite Control}
  134.  kbderrorflag:         char = ' ';  {keyboard error occurred flag}
  135.  keyboardstatuschange: char = ' ';  {detect numlock press and save}
  136.  searchflag:           char = ' ';
  137.  charvalue:            integer = 0; {ordinal value of field charin }
  138.  clrlimit:             shortint= 0; {last line to be cleared on panel}
  139.  column:               shortint= 0; {screen column address}
  140.  columncount:          shortint= 0; {screen column counter}
  141.  currentoffset:        word    = 0; {memory loc. field start on screen}
  142.  cvtresult:            integer = 0; {character to number conversion }
  143.                                     {error result checker}
  144.  datasegment:          word= $0000; {segment address for data segment}
  145.  decimalcount:         shortint= 0; {working field for no. of decimals}
  146.  endrow:               shortint= 0; {last row number of field}
  147.  endcolumn:            shortint= 0; {last column in field}
  148.  errornumber:          shortint= 0; {index to keyboard error array}
  149.  maxfields:            integer = 0; {number of data fields in a format}
  150.  multiplier:           longint = 0; {factor or 10 to remove or insert }
  151.                                     {decimals in screen field}
  152.  offset:               shortint= 0; {cursor movement offset from }
  153.                                     {current location negative value}
  154.                                     {means move left,positive=right}
  155.  row:                  shortint= 0; {screen field row address}
  156.  scolumn:              shortint= 0; {screen field column address}
  157.  displayadapteroffset: word =$0000; {start of display memory offset}
  158.  srow:                 shortint= 0; {screen field row address}
  159.  workindex:            integer = 0; {index to array of data fields or}
  160.                                     {constant fields}
  161.  { work areas for input/output conversion routines}
  162.  workaddress:       word = 0;
  163.  workinteger:       integer = 0;
  164.  workshortint:      shortint= 0;
  165.  worklongint:       longint = 0;
  166.  workreal:          real    = 0.0;
  167.  blanktest:         string[80]='';{test input or both types for blanks}
  168.  cursorrightcode:   byte = $73;   {5250 Cursor Right Scan Code}
  169.  errorresetcode:    byte = $7E;   {5250 Error Reset Scan Code}
  170.  fieldadvancecode:  byte = $20;   {5250 Field Advance Key PC Tab Key}
  171.  fieldminuscode:    byte = $4E;   {5250 Field Minus Key PC Minus Key}
  172.  homecursorcode:    byte = $6D;   {5250 Home Cursor Scan Code}
  173.  em5250segment:     word = $0000; {emulator segment address}
  174.  screenoffset:      word = $0000; {address offset of emulated screen}
  175.  ebcdictableoffset: word = $0000; {address offset of start of ebcdic to
  176.                                    ascii translate table}
  177.  inpbuffersegment:  word = $0000; {segment address of input buffer string}
  178.  inpbufferoffset:   word = $0000; {offset address of input buffer string}
  179.  inputinhibit:      word = $013E; {offset to input inhibited indicator byte}
  180.  inhibithistory:    word = $013F; {offset to inhibit indicator history byte}
  181.  inz38flag:         char    = ' ';{s38 emulator variables established flag}
  182.  keyo:              word = $0151; {address to send scan codes to}
  183.  surx:              word = $0164; {Emulator EBCDIC Display Change Indicator}
  184.  systemavailable:   word = $015B; {address of system available ind. byte}
  185.  hotkey:            word = $0178; {address of hot-key indicator}
  186.  hkcol:             word = $017B; {address auto hot-key char.5250 column}
  187.  hkrow:             word = $017C; {address auto hot-key char 5250 row}
  188.  hkchar:            word = $017D; {address containing auto hot-key char}
  189.  hotkeychar:        char = ' ';   {character on s38 format forces DOS hot key}
  190.  statusmessage:     string[70]='';{System Available & Input Inhibit Message}
  191.  zerorealtest:      real = 0.0;   {test input or both types for zero.}
  192.  asciitranslatetable: array[1..128] of byte =
  193.   ($00,$40,$40,$40,$40,$40,$40,$40,$40,$40,$40,$40,$40,
  194.    $40,$40,$40,$40,$40,$40,$40,$40,$40,$40,$40,$40,$40,
  195.    $40,$40,$40,$40,$40,$40,$40,$4F,$7F,
  196.    $7B,$5B,$6C,$50,$7D,$4D,$5D,$5C,$4E,$6B,$60,$4B,$61,
  197.    $F0,$F1,$F2,$F3,$F4,$F5,$F6,$F7,$F8,$F9,$7A,$5E,$4C,
  198.    $7E,$6E,$6F,$7C,$C1,$C2,$C3,$C4,$C5,$C6,$C7,$C8,$C9,
  199.    $D1,$D2,$D3,$D4,$D5,$D6,$D7,$D8,$D9,$E2,$E3,$E4,$E5,
  200.    $E6,$E7,$E8,$E9,$4A,$E0,$5A,$5F,$6D,$79,$81,$82,$83,
  201.    $84,$85,$86,$87,$88,$89,$91,$92,$93,$94,$95,$96,$97,
  202.    $98,$99,$A2,$A3,$A4,$A5,$A6,$A7,$A8,$A9,$C0,$6A,$D0,
  203.    $A1,$8F); {ascii to ebcdic translate table}
  204.  scancode5250table:  array[1..128] of byte =
  205.   ($00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,
  206.    $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,
  207.    $00,$00,$00,$00,$00,$00,$0F,$2B,$1B,
  208.    $33,$34,$35,$37,$1B,$39,$3A,$38,$3C,$08,$3B,$09,$0A,
  209.    $40,$41,$42,$43,$44,$45,$46,$47,$48,$49,$1A,$1A,$0E,
  210.    $3C,$0E,$0A,$32,$11,$05,$03,$13,$23,$14,$15,$16,$28,
  211.    $17,$18,$19,$07,$06,$29,$28,$21,$24,$12,$25,$27,$04,
  212.    $22,$02,$26,$01,$2B,$2C,$2B,$36,$3B,$3E,$11,$05,$03,
  213.    $13,$23,$14,$15,$16,$28,$17,$18,$19,$07,$06,$29,$2A,
  214.    $21,$24,$12,$25,$27,$04,$22,$02,$26,$01,$1C,$2C,$1C,
  215.    $3E,$31); {ascii to 5250 scan code table}
  216. Type
  217.   fixstringz      =  string[80];
  218.   screenpointer   =  ^screenrecord;
  219.   screenrecord    =  record
  220.     savescreenarea:  array[1..4000] of byte;
  221.     prevscreen:      screenpointer;
  222.     saveindex:       fpointer;
  223.     savebuffer:      string[80];
  224.     saveformatcount: formatpointer;
  225.   end;
  226.  
  227.  formatrecord = record               {field description disk & array record}
  228.     screenrow:            integer;   {row starting location of field}
  229.     screencol:            integer;   {column starting location of field}
  230.     fieldlen:             byte;      {Length Of Field Including Decimals If Any}
  231.     fill2:                byte;
  232.     fielddec:             byte;      {Number Of Decimal Positions In Field}
  233.     lowercas:             char;      {Allow Lower Case Entry If NonBlank}
  234.     datatype:             char;      {C=Character or String,N=Integer or Real}
  235.     iotype:               char;      {I=Input Only, O=Output Only, B=Both}
  236.     fieldnam:             string[8];
  237.     fmtname:              string[8]; {Name Of This Format(Screen Panel)}
  238.     screenname:           string[8]; {Name Of File Containing Panel Description}
  239.     bkcolor:              byte;      {Background color}
  240.     position:             byte;      {Position Cursor To Field Indicator}
  241.     txcolor:              byte;      {Text Display Color}
  242.     protect:              byte;      {Protect Field From Input Indicator}
  243.     rvrsimg:              byte;      {Indicator 01-99 if 1 Colors Are Reversed}
  244.     blink:                byte;      {Field Will Blink If Indicator Is On}
  245.     errorind:             byte;      {Indicator 01-99 if 1 Error Msg. Displayed}
  246.                                      {error message stored in constandata}
  247.     fill4:                byte;
  248.     constantdata:  string[80];
  249.    end;
  250.  
  251.   formatheader = record         {format header information disk record}
  252.    bkintcol:         integer;   {initial background color}
  253.    txintcol:         integer;   {initial text color}
  254.    putovr:           integer;   {rewrite screen inidicator}
  255.    eraseinp:         integer;   {erase input fields if on & putovr on ind}
  256.    hfmtname:         string[8]; {name of format}
  257.    screenname:       string[8]; {name of screen file}
  258.    clrline:          integer;   {number of lines to clear from 1st line}
  259.    helpname:         string[8]; {Name Of Help Format}
  260.    commandkeymask:   cmdarray;  {Valid Command Keys This Format}
  261.    reservedarea:     string[32];{Reserved For Future Use}
  262.   end;
  263. var
  264.   screensaveheap:  screenrecord;
  265. const
  266.   firsthelpscreen: screenpointer=nil;
  267.   lasthelpscreen:  screenpointer=nil;
  268.   newhelpscreen:   screenpointer=nil;
  269.  
  270. procedure setstatusline(messagecolor,delaytime:integer);
  271.   begin
  272.     gotoxy(1,25);
  273.     textcolor(messagecolor);
  274.     textbackground(1);
  275.     delay(delaytime);
  276.     clreol;
  277.   end;
  278.  
  279. procedure emulatorstatusmessage;
  280.   begin
  281.     setstatusline(4,0);
  282.     write(statusmessage);
  283.     setstatusline(15,50);
  284.   end;
  285.  
  286. procedure checkinputinhibit;
  287.   begin
  288.    statusmessage:='Input Inhibited';
  289.    emulatorstatusmessage;
  290.    while ((mem[em5250segment:inputinhibit] and 2) = 0) or
  291.          ((mem[em5250segment:inhibithistory] and 2) =2) do
  292.          emulatorstatusmessage;
  293.   end;
  294.  
  295. procedure calculateoffset (rowloc,columnloc: integer);
  296. begin
  297.  currentoffset:=((rowloc * 80) - 81) + columnloc;
  298. end;
  299.  
  300. procedure Savescreen(fieldpointer: fpointer);
  301.   begin
  302.     getmem(newhelpscreen,(sizeof(screensaveheap)));
  303.     if firsthelpscreen=nil then begin
  304.        firsthelpscreen:=newhelpscreen;
  305.        lasthelpscreen:=nil;
  306.     end;
  307.     move(mem[displayadaptersegment:displayadapteroffset],
  308.          newhelpscreen^.savescreenarea,4000);
  309.     newhelpscreen^.prevscreen:=lasthelpscreen;
  310.     newhelpscreen^.saveindex:=fieldpointer;
  311.     newhelpscreen^.savebuffer:=inpbuffer;
  312.     newhelpscreen^.saveformatcount:=currentformat;
  313.     lasthelpscreen:=newhelpscreen;
  314.     helplevel:=helplevel+1;
  315.   end;
  316.  
  317. procedure Restorescreen(var fieldpointer:fpointer);
  318.  var savelast: screenpointer;
  319.  begin
  320.    helplevel:=helplevel-1;
  321.    move(lasthelpscreen^.savescreenarea,
  322.         mem[displayadaptersegment:displayadapteroffset],4000);
  323.    fieldpointer:=lasthelpscreen^.saveindex;
  324.    if lasthelpscreen^.prevscreen=nil then begin
  325.       inpbuffer:=lasthelpscreen^.savebuffer;
  326.       gotoxy(scolumn,srow);
  327.       firsthelpscreen:=nil;
  328.    end;
  329.    if lasthelpscreen<>nil then begin
  330.       savelast:=lasthelpscreen^.prevscreen;
  331.       currentformat:=lasthelpscreen^.saveformatcount;
  332.       freemem(lasthelpscreen,(sizeof(screensaveheap)));
  333.       lasthelpscreen:=savelast;
  334.    end;
  335.   end;
  336.  
  337. procedure autohotkey;
  338.   var
  339.     hotkeyrowbyte,hotkeycolumnbyte: byte;
  340.     regs: registers;
  341.   begin
  342.     checkinputinhibit;
  343.     while mem[em5250segment:surx]=$00 do begin end;
  344.     delay(400);
  345.     checkinputinhibit;
  346.     hotkeyrowbyte:=hotkeyrow;
  347.     hotkeycolumnbyte:=hotkeycolumn;
  348.     mem[em5250segment:hkrow]:=hotkeyrowbyte;
  349.     mem[em5250segment:hkcol]:=hotkeycolumnbyte;
  350.     mem[em5250segment:hkchar]:=asciitranslatetable[(ord(hotkeychar)+1)];
  351.     if (mem[em5250segment:hotkey] and 1)<>1 then
  352.        mem[em5250segment:hotkey]:=mem[em5250segment:hotkey] xor $01;
  353.     with regs do intr(9,regs);
  354.     if (mem[em5250segment:hotkey] and 1)=1 then
  355.        mem[em5250segment:hotkey]:=mem[em5250segment:hotkey] xor $01;
  356.     mem[em5250segment:hkrow]:=$00;
  357.     mem[em5250segment:hkcol]:=$00;
  358.     mem[em5250segment:hkchar]:=$00;
  359.   end;
  360.  
  361. procedure sendfieldexit;
  362.   begin
  363.     if (sendendoffield=entercode) or (sendendoffield=commandcode) then begin
  364.        checkinputinhibit;
  365.        mem[em5250segment:inputinhibit]:=$00;
  366.        mem[em5250segment:inhibithistory]:=$FF;
  367.     end;
  368.     while mem[em5250segment:keyo]<>$00 do begin end;
  369.     mem[em5250segment:keyo]:=sendendoffield;
  370.     mem[em5250segment:surx]:=$00; {set screen change ind. to zero to allow}
  371.   end;                           {detection of a change in the emulator screen}
  372.  
  373. procedure systemrequest;
  374.   var dummy: char;
  375.       cursorx: shortint;
  376.       cursory: shortint;
  377.   begin
  378.     cursorx:=wherex;
  379.     cursory:=wherey;
  380.     sound(500);
  381.     statusmessage:='System Req./ATTN Pressed--Press ESC To Exit, Any Other Key Continue';
  382.     emulatorstatusmessage;
  383.     nosound;
  384.     while not keypressed do emulatorstatusmessage;
  385.     charin:=readkey;
  386.     if keypressed then dummy:=readkey;
  387.     gotoxy(cursorx,cursory);
  388.     if ord(charin)<>$1B then begin
  389.        checkinputinhibit;
  390.        if charvalue>59 then sendfieldexit($57);
  391.        sendfieldexit(systemrequestcode);
  392.        autohotkey(0,0,#0);
  393.     end;
  394.   end;
  395.  
  396. procedure seton;
  397.  begin
  398.    _in[indicatornum]:='1';
  399.  end;
  400.  
  401. procedure setof;
  402.  begin
  403.    _in[indicatornum]:='0';
  404.  end;
  405.  
  406. procedure resetind; {reset all indicators in indicator array}
  407.    begin
  408.      fillchar(_in[1],100,'0');
  409.    end;
  410.  
  411. procedure errorsound(freq,wait:integer);
  412.  begin
  413.   sound(freq);
  414.   delay(wait);
  415.   nosound;
  416.  end;
  417.  
  418. procedure clearbottomline;
  419.   begin
  420.     gotoxy(1,25);
  421.     if (bottomlinebackground=0) and (bottomlineforeground<>4) and
  422.     (bottomlineforeground<>12) then bottomlinebackground:=4;
  423.     textcolor(bottomlineforeground);
  424.     textbackground(bottomlinebackground);
  425.     clreol;
  426.   end;
  427.  
  428. procedure keyboarderror(errornumber: integer);
  429.  begin
  430.    clearbottomline;
  431.    write(errormsg[errornumber]);
  432.    errorsound(500,600);
  433.    gotoxy(scolumn,srow);
  434.    kbderrorflag:='1';
  435.  end;
  436.  
  437. procedure fixstring(address:word;fieldlen:integer;siotype,sdatatype,ioflag:char);
  438.  var
  439.    blankloc:    integer;   {position of first blank character}
  440.    sfieldlen:   integer;   {defined field length}
  441.    workseg:     word;
  442.  begin
  443.   if (ioflag='U') or (ioflag='I') then begin
  444.      workaddress:=ofs(inpbuffer);
  445.      workseg:=seg(inpbuffer);
  446.  end;
  447.  case ioflag of
  448.  'O': begin
  449.        workaddress:=ofs(charoutbuffer);
  450.        workseg:=seg(charoutbuffer);
  451.        blankloc:=ord(mem[datasegment:address]);
  452.        mem[datasegment:address]:=ord(chr(fieldlen));
  453.        if blankloc>fieldlen then blankloc:=0;
  454.        while blankloc<fieldlen do begin
  455.           blankloc:=blankloc+1;
  456.           mem[datasegment:address + blankloc]:=$20;
  457.        end;
  458.        move(mem[datasegment:address],mem[workseg:workaddress],(fieldlen+1));
  459.        if (siotype='I') then fillchar(mem[datasegment:(address + 1)],
  460.           fieldlen,' ');
  461.      end;
  462.  'U': begin
  463.         inpbuffer:='';
  464.         blankloc:=(ord(mem[datasegment:address]))+1;
  465.         move(mem[datasegment:address],mem[workseg:workaddress],blankloc);
  466.         while length(inpbuffer)<fieldlen do begin
  467.           if sdatatype='C' then inpbuffer:=inpbuffer + ' '
  468.           else inpbuffer:=' ' + inpbuffer;
  469.         end;
  470.         move(inpbuffer,mem[datasegment:address],(length(inpbuffer)+1));
  471.       end;
  472.  'I': begin
  473.         if sdatatype='R' then begin
  474.            blankloc:=pos(' ',inpbuffer);
  475.            sfieldlen:=length(inpbuffer);
  476.            if blankloc>1 then begin
  477.               inpbuffer:=copy(inpbuffer,1,(blankloc-1));
  478.               for blankloc:=blankloc to sfieldlen do inpbuffer:=' ' + inpbuffer;
  479.           end;
  480.         end;
  481.         sfieldlen:=length(inpbuffer)+1;
  482.         move(mem[workseg:workaddress],mem[datasegment:address],sfieldlen);
  483.       end;
  484.    end;
  485.  end;
  486.  
  487. procedure fixreal (address:word;rfieldlen,rfielddec: integer;
  488.                    riotype,rdatatype,ioflag: char);
  489. var savesign: char;
  490.  
  491. procedure ofixreal(address:word;orfieldlen,orfielddec: integer;
  492.                   oriotype,ordatatype,ioflag:char);
  493.  var workseg: word;
  494.  begin
  495.    workaddress:=ofs(workreal);
  496.    workseg:=seg(workreal);
  497.    move(mem[datasegment:address],mem[workseg:workaddress],6);
  498.    if workreal<0 then begin
  499.       savesign:='-';
  500.       workreal:=abs(workreal);
  501.    end
  502.    else savesign:=' ';
  503.    if ordatatype<>'E' then begin
  504.       workreal:=workreal*multiplier;
  505.       orfielddec:=0;
  506.    end
  507.    else orfieldlen:=orfieldlen + 1;
  508.    str(workreal:orfieldlen:orfielddec,inpbuffer);
  509.    if ordatatype<>'N' then inpbuffer:=inpbuffer + savesign;
  510.    if ioflag='O' then begin
  511.       charoutbuffer:=inpbuffer;
  512.       if (oriotype='I') then begin
  513.          workreal:=0;
  514.          move(mem[workseg:workaddress],mem[datasegment:address],6);
  515.       end;
  516.    end;
  517.  end;
  518.  
  519. procedure ifixreal(address:word;irfieldlen,irfielddec: integer;
  520.                   iriotype,irdatatype,ioflag:char);
  521.   var workseg: word;
  522.   begin
  523.     savesign:=' ';
  524.     workaddress:=ofs(workreal);
  525.     workseg:=seg(workreal);
  526.     if irdatatype='E' then irfieldlen:=irfieldlen + 1;
  527.     if irdatatype<>'N' then begin
  528.        savesign:=inpbuffer[irfieldlen + 1];
  529.        inpbuffer:=copy(inpbuffer,1,irfieldlen);
  530.     end;
  531.     val(inpbuffer,workreal,cvtresult);
  532.     if cvtresult<>0 then keyboarderror(9);
  533.     if irdatatype<>'E' then workreal:=workreal/multiplier;
  534.     if savesign='-' then workreal:=0-workreal;
  535.     move(mem[workseg:workaddress],mem[datasegment:address],6);
  536.     if irdatatype<>'N' then inpbuffer:=inpbuffer+savesign;
  537.   end;
  538.  
  539.    begin
  540.      case ioflag of
  541.     'U','O': ofixreal (address,rfieldlen,rfielddec,riotype,rdatatype,ioflag);
  542.         'I': ifixreal (address,rfieldlen,rfielddec,riotype,rdatatype,ioflag);
  543.      end;
  544.    end;
  545.  
  546. procedure fixinteger (address:word;ifieldlen,ifielddec:
  547.                       integer; iiotype,idatatype,ioflag: char);
  548.   var
  549.     savesign:    char;
  550.     workcounter: longint;
  551.     targetsize:  shortint;
  552.     workseg:     word;
  553.     workofs:     word;
  554. procedure ofixinteger(address:word;oifieldlen,oifielddec:
  555.                       integer; oiiotype,oidatatype,ioflag:char);
  556. begin
  557.    move(mem[datasegment:address],mem[(seg(workinteger)):workofs],targetsize);
  558.    case targetsize of
  559.     1: worklongint:=workshortint;
  560.     2: worklongint:=workinteger;
  561.    end;
  562.    if worklongint<0 then savesign:='-';
  563.    worklongint:=abs(worklongint);
  564.    str(worklongint:oifieldlen,inpbuffer);
  565.    if oidatatype<>'N' then inpbuffer:=inpbuffer + savesign;
  566.    if ioflag='O' then begin
  567.       charoutbuffer:=inpbuffer;
  568.       if oiiotype='I' then begin
  569.          workcounter:=0;
  570.          move(workcounter,mem[datasegment:address],targetsize);
  571.       end;
  572.    end;
  573.  end;
  574.  
  575. procedure ifixinteger(address:word; iifieldlen,iifielddec:
  576.                       integer; iiiotype,iidatatype,ioflag:char);
  577.   begin
  578.     if iidatatype<>'N' then begin
  579.        savesign:=inpbuffer[iifieldlen + 1];
  580.        inpbuffer:=copy(inpbuffer,1,iifieldlen);
  581.     end;
  582.     val(inpbuffer,worklongint,cvtresult);
  583.     if savesign='-' then worklongint:=0-worklongint;
  584.     if iidatatype<>'N' then inpbuffer:=inpbuffer + savesign;
  585.     if targetsize=4 then move(worklongint,mem[datasegment:address],4)
  586.     else begin
  587.       workinteger:=worklongint;
  588.       move(workinteger,mem[datasegment:address],targetsize);
  589.     end;
  590.   end;
  591.  
  592.  begin
  593.   savesign:=' ';
  594.   case  ifieldlen of
  595.    1..2: begin
  596.            targetsize:=1;
  597.            workofs:=ofs(workshortint);
  598.          end;
  599.    3..4: begin
  600.            targetsize:=2;
  601.            workofs:=ofs(workinteger);
  602.          end;
  603.    5..9: begin
  604.            targetsize:=4;
  605.            workofs:=ofs(worklongint);
  606.          end;
  607.   end;
  608.   case ioflag of
  609.   'U','O': ofixinteger (address,ifieldlen,ifielddec,iiotype,idatatype,ioflag);
  610.   'I':     ifixinteger (address,ifieldlen,ifielddec,iiotype,idatatype,ioflag);
  611.    end;
  612.  end;
  613.  
  614.  Procedure Checknumeric(address: word; iotype,datatype: char; fieldlen,
  615.                         fielddec: integer; ioflag:char);
  616.     begin
  617.       if (fieldlen>9) or (fielddec>0)
  618.       then fixreal(address,fieldlen,fielddec,iotype,datatype,ioflag)
  619.       else fixinteger(address,fieldlen,fielddec,iotype,datatype,ioflag);
  620.     end;
  621.  
  622. Procedure Checkfield(ioflag: char; fieldpointer:fpointer);
  623. Begin
  624. multiplier:=1;
  625. for decimalcount:=1 to fieldpointer^.fielddec do multiplier:=multiplier * 10;
  626. datasegment:=dseg;
  627. case fieldpointer^.datatype of
  628.  'C','R': fixstring(fieldpointer^.fieldoffset,fieldpointer^.fieldlen,
  629.                     fieldpointer^.iotype,fieldpointer^.datatype,ioflag);
  630.  else  checknumeric(fieldpointer^.fieldoffset,fieldpointer^.iotype,
  631.                     fieldpointer^.datatype,fieldpointer^.fieldlen,
  632.                     fieldpointer^.fielddec,ioflag);
  633. end;
  634. end;
  635.  
  636. procedure positioncursor;
  637.   begin
  638.     if srow>24 then srow:=1;
  639.     if srow<1  then srow:=24;
  640.     gotoxy(scolumn,srow);
  641.   end;
  642.  
  643.   procedure toggleinsertmode;
  644.     begin
  645.       clearbottomline;
  646.       if insertmodeflag='1' then insertmodeflag:=' '
  647.       else begin
  648.         gotoxy(30,25);
  649.         write('Insert Mode');
  650.         Insertmodeflag:='1';
  651.       end;
  652.       offset:=1;
  653.       positioncursor;
  654.     end;
  655.  
  656. procedure checkind(var indicatornumber:byte);
  657.   begin
  658.    if (indicatornumber<1) or (indicatornumber>99) then indicatornumber:=100;
  659.   end;
  660.  
  661. procedure openscreenfile;
  662. var
  663.  keyboardstatus:         byte absolute $0040:$0017;
  664.  capslockstatus:         byte absolute $0040:$0018;
  665.  screenfile:             file of formatrecord;
  666.  zformatcontrl:          file of formatheader;
  667.  formatheaderwork:       formatheader;
  668.  firstformat:            formatpointer absolute format1;
  669.  lastformat:             formatpointer;
  670.  firstfield:             fpointer;
  671.  cfield:                 fpointer;
  672.  firstconstant:          fpointer;
  673.  ccons:                  fpointer;
  674.  lastconstant:           fpointer;
  675.  lastfield:              fpointer;
  676.  screenwork:             formatrecord;
  677.  screenheap:             screenfields;
  678.  formatheap:             formatswork;
  679.  segment:                integer;
  680.  offsetp:                integer;
  681.  ioerr:                  integer;
  682.  testbyte:               byte;
  683. begin
  684. {$I+}
  685. {check and ensure numlock is set}
  686. if (keyboardstatus and $20)=0 then keyboardstatus:=keyboardstatus xor $20;
  687. keyboardstatuschange:=' ';
  688. assign(screenfile,screenfilename);
  689. assign(zformatcontrl,(screenfilename + '.hdr'));
  690. reset(screenfile);
  691. reset(zformatcontrl);
  692. resetind;
  693. firstformat:=nil;
  694. firstfield:=nil;
  695. firstconstant:=nil;
  696. textcolor(1);
  697. textbackground(1);
  698. clrscr;
  699. mem[displayadaptersegment:$0000]:=ord('A');
  700. testbyte:=mem[displayadaptersegment:$0000];
  701. if testbyte=ord('A') then displayadapteroffset:=$0000
  702. else displayadapteroffset:=$8000;
  703. mem[displayadaptersegment:$8000]:=ord('A');
  704. testbyte:=mem[displayadaptersegment:$8000];
  705. if testbyte=ord('A') then displayadapteroffset:=$8000
  706. else displayadapteroffset:=$0000;
  707. textcolor(15);
  708. previousformatname:='';
  709. while not eof(screenfile) do begin
  710.   with screenwork do begin
  711.      read(screenfile,screenwork);
  712.      if displayadapteroffset=$0000 then begin
  713.         txcolor:=15;
  714.         bkcolor:=1;
  715.      end;
  716.      if fieldnam='Constant' then getmem(ccons,(sizeof(screenheap)))
  717.      else getmem(cfield,(sizeof(screenheap)));
  718.      if previousformatname<>fmtname then begin
  719.         getmem(currentformat,(sizeof(formatheap)));
  720.         if firstformat=nil then firstformat:=currentformat
  721.         else lastformat^.nextformat:=currentformat;
  722.         with formatheaderwork do begin
  723.           read(zformatcontrl,formatheaderwork);
  724.           previousformatname:=fmtname;
  725.           currentformat^.firstconstant:=nil;
  726.           currentformat^.firstfield:=nil;
  727.           if displayadapteroffset=$0000 then begin
  728.              bkintcol:=1;
  729.              txintcol:=15;
  730.           end;
  731.           currentformat^.wformatname:=fmtname;
  732.           currentformat^.wscreenrow:=screenrow;
  733.           currentformat^.wscreencol:=screencol;
  734.           currentformat^.wbkintcolor:=bkintcol;
  735.           currentformat^.wtxintcolor:=txintcol;
  736.           currentformat^.wputovr:=putovr;
  737.           currentformat^.weraseinp:=eraseinp;
  738.           currentformat^.wclrline:=clrline;
  739.           currentformat^.wcommandkeymask:=commandkeymask;
  740.           currentformat^.whelpname:=helpname;
  741.           if (currentformat^.wputovr<1) or (currentformat^.wputovr>99)
  742.              then currentformat^.wputovr:=100;
  743.           if (currentformat^.weraseinp<1) or (currentformat^.weraseinp>99)
  744.              then currentformat^.weraseinp:=100;
  745.           if fieldnam='Constant' then begin
  746.              currentformat^.firstconstant:=ccons;
  747.              firstconstant:=nil;
  748.           end
  749.           else begin
  750.             currentformat^.firstfield:=cfield;
  751.             firstfield:=nil;
  752.          end;
  753.          lastformat:=currentformat;
  754.          currentformat^.nextformat:=nil;
  755.        end;
  756.     end
  757.     else begin
  758.       if (currentformat^.firstconstant=nil) and (fieldnam='Constant')
  759.          then begin
  760.            currentformat^.firstconstant:=ccons;
  761.            firstconstant:=nil;
  762.       end;
  763.       if (currentformat^.firstfield=nil) and (fieldnam<>'Constant')
  764.          then begin
  765.           currentformat^.firstfield:=cfield;
  766.           firstfield:=nil;
  767.       end;
  768.     end;
  769.     if fieldnam='Constant' then begin
  770.        if firstconstant=nil then begin
  771.           firstconstant:=ccons;
  772.           lastconstant:=nil;
  773.        end
  774.        else lastconstant^.nextfield:=ccons;
  775.        segment:=seg(ccons^);
  776.        offsetp:=ofs(ccons^);
  777.        move(screenwork,mem[segment:offsetp],(sizeof(screenwork)));
  778.        ccons^.nextfield:=nil;
  779.        lastconstant:=ccons;
  780.        checkind(ccons^.rvrsimg);
  781.        checkind(ccons^.blink);
  782.     end
  783.     else begin
  784.      if firstfield=nil then begin
  785.         firstfield:=cfield;
  786.         lastfield:=nil;
  787.      end
  788.      else lastfield^.nextfield:=cfield;
  789.      segment:=seg(cfield^);
  790.      offsetp:=ofs(cfield^);
  791.      move(screenwork,mem[segment:offsetp],(sizeof(screenwork)));
  792.      checkind(cfield^.rvrsimg);
  793.      checkind(cfield^.errorind);
  794.      checkind(cfield^.protect);
  795.      checkind(cfield^.position);
  796.      checkind(cfield^.blink);
  797.      cfield^.nextfield:=nil;
  798.      cfield^.prvfield:=lastfield;
  799.      lastfield:=cfield;
  800.     end;
  801.   end;
  802.  end;
  803.  inzscreen:='1';
  804.  firstscreenseg:=seg(firstformat^);
  805.  firstscreenofs:=ofs(firstformat^);
  806.  close(screenfile);
  807.  close(zformatcontrl);
  808. end;
  809.  
  810. procedure calculatescreenoffset(rowaddress,columnaddress: integer);
  811.  begin
  812.   currentoffset:=((rowaddress*160) -162) + columnaddress + columnaddress;
  813.  end;
  814.  
  815. procedure defaultcolor(var dbkcolor,dtxcolor:byte; dbkint,dtxint:integer);
  816.   begin
  817.     if dbkcolor=0 then dbkcolor:=dbkint;
  818.     if dtxcolor=0 then dtxcolor:=dtxint;
  819.   end;
  820.  
  821. procedure findformat(firstformat: formatpointer; usefmtname:fmtnamestring);
  822.   begin
  823.     currentformat:=firstformat;
  824.     searchflag:=' ';
  825.     repeat
  826.       if currentformat^.wformatname=usefmtname then searchflag:='1'
  827.       else currentformat:=currentformat^.nextformat;
  828.       if currentformat=nil then begin
  829.          keyboarderror(11);
  830.          halt;
  831.       end;
  832.     until (searchflag='1') or (currentformat=nil);
  833.     bottomlineforeground:=currentformat^.wtxintcolor;
  834.     bottomlinebackground:=currentformat^.wbkintcolor;
  835.  end;
  836.  
  837. procedure writescreen;
  838.  var
  839.   bytecount:    integer;
  840.   zscreenrow:   integer;
  841.   inputwork:    string[80];
  842.   wxformat:     string[8];
  843.  firstformat:   formatpointer absolute format1;
  844.  workpointer:   fpointer;
  845.  
  846. procedure screenoutput(dataout: fixstringz;
  847.           outputlength,bkcol,txcol,rvrs,blink: byte);
  848. var
  849.  setcolor:      byte;
  850.  outputword:    array[1..2] of byte;
  851.  paramoffset:   word;
  852.  paramsegment:  word;
  853.  savescroffset: word;
  854. begin
  855.    savescroffset:=displayadapteroffset + currentoffset;
  856.    paramoffset:=ofs(dataout) + 1;
  857.    paramsegment:=seg(dataout);
  858.    if bkcol>15 then bkcol:=1;
  859.    if txcol>15 then txcol:=1;
  860.    if rvrs=0 then rvrs:=100;
  861.    if (_in[rvrs]<>'1') and (_in[rvrs]<>'0') then _in[rvrs]:='0';
  862.    if _in[rvrs]='0' then outputword[2]:=
  863.       backgroundcolortable[(bkcol + 1)] + textcolortable[(txcol + 1)]
  864.    else outputword[2]:=
  865.       backgroundcolortable[txcol + 1] + textcolortable[bkcol + 1];
  866.    if _in[blink]='1' then outputword[2]:=outputword[2]+$80;
  867.    for paramoffset:=paramoffset to (paramoffset + outputlength - 1) do begin
  868.       outputword[1]:=mem[paramsegment:paramoffset];
  869.       move(outputword,mem[displayadaptersegment:savescroffset],2);
  870.       savescroffset:=savescroffset + 2;
  871.    end;
  872.  end;
  873.  
  874. begin
  875.  commandkey:=' ';
  876.  searchflag:=' ';
  877.  if currentformat^.wformatname<>usefmtname then
  878.     findformat(firstformat,usefmtname);
  879.  if (currentformat^.wbkintcolor=0) and (currentformat^.wtxintcolor=0) then
  880.     currentformat^.wtxintcolor:=15;
  881.  if (_in[currentformat^.wputovr]='0') and (inputfieldonlyflag<>'1') then begin
  882.    textcolor(currentformat^.wtxintcolor);
  883.    textbackground(currentformat^.wbkintcolor);
  884.    if currentformat^.wclrline=0 then clrscr
  885.    else begin
  886.      clrlimit:=currentformat^.wscreenrow + currentformat^.wclrline;
  887.      if clrlimit>25 then clrlimit:=25;
  888.      for zscreenrow:=currentformat^.wscreenrow to clrlimit do begin
  889.        gotoxy(1,zscreenrow);
  890.        clreol;
  891.      end;
  892.    end;
  893.    fieldpointer:=currentformat^.firstconstant;
  894.    while fieldpointer<>nil do begin
  895.     calculatescreenoffset(fieldpointer^.screenrow,fieldpointer^.screencol);
  896.     defaultcolor(fieldpointer^.bkcolor,fieldpointer^.txcolor,
  897.       currentformat^.wbkintcolor,currentformat^.wtxintcolor);
  898.     screenoutput(fieldpointer^.constantdata,fieldpointer^.fieldlen,
  899.       fieldpointer^.bkcolor,fieldpointer^.txcolor,fieldpointer^.rvrsimg,
  900.       fieldpointer^.blink);
  901.     fieldpointer:=fieldpointer^.nextfield;
  902.    end;
  903.   end;
  904.   fieldpointer:=currentformat^.firstfield;
  905.   if fieldpointer<>nil then begin
  906.      repeat
  907.       calculatescreenoffset(fieldpointer^.screenrow,fieldpointer^.screencol);
  908.       defaultcolor(fieldpointer^.bkcolor,fieldpointer^.txcolor,
  909.            currentformat^.wbkintcolor,currentformat^.wtxintcolor);
  910.       if ((fieldpointer^.iotype='I') and (_in[currentformat^.wputovr]='0')) or
  911.          ((fieldpointer^.iotype='I') and (_in[currentformat^.wputovr]='1') and
  912.          (_in[currentformat^.weraseinp]='1')) then begin
  913.          inpbuffer:='';
  914.          fillchar(inpbuffer,(fieldpointer^.fieldlen+1),'.');
  915.          inpbuffer[0]:=chr(fieldpointer^.fieldlen);
  916.          screenoutput(inpbuffer,fieldpointer^.fieldlen,fieldpointer^.bkcolor,
  917.          fieldpointer^.txcolor,fieldpointer^.rvrsimg,fieldpointer^.blink);
  918.          if (fieldpointer^.datatype='C') or (fieldpointer^.datatype='R') then
  919.             fillchar(inpbuffer,(fieldpointer^.fieldlen + 1),' ')
  920.          else fillchar(inpbuffer,(fieldpointer^.fieldlen + 1),'0');
  921.          inpbuffer[0]:=chr(fieldpointer^.fieldlen);
  922.       end;
  923.       if (fieldpointer^.iotype='I') and (_in[currentformat^.wputovr]='1') and
  924.          (_in[currentformat^.weraseinp]='0') then begin
  925.          fieldpointer^.iotype:='B';
  926.          checkfield('O',fieldpointer);
  927.          fieldpointer^.iotype:='I';
  928.       end
  929.       else checkfield('O',fieldpointer);
  930.       if (fieldpointer^.iotype<>'I') or ((fieldpointer^.iotype='I') and
  931.          (_in[currentformat^.wputovr]='1') and
  932.          (_in[currentformat^.weraseinp]='0')) then begin
  933.          if (fieldpointer^.datatype = 'S') or (fieldpointer^.datatype = 'E')
  934.          then fieldpointer^.fieldlen:=fieldpointer^.fieldlen + 1;
  935.          if (fieldpointer^.datatype='E') and (fieldpointer^.fielddec>0) then
  936.             fieldpointer^.fieldlen:=fieldpointer^.fieldlen+1;
  937.          repeat
  938.            if length(charoutbuffer)<fieldpointer^.fieldlen then
  939.               charoutbuffer:=charoutbuffer + ' ';
  940.          until length(charoutbuffer)>=fieldpointer^.fieldlen;
  941.          screenoutput(charoutbuffer,fieldpointer^.fieldlen,
  942.             fieldpointer^.bkcolor,fieldpointer^.txcolor,fieldpointer^.rvrsimg,
  943.             fieldpointer^.blink);
  944.          if (fieldpointer^.datatype = 'S') or (fieldpointer^.datatype = 'E')
  945.             then fieldpointer^.fieldlen:=fieldpointer^.fieldlen-1;
  946.          if (fieldpointer^.datatype='E') and (fieldpointer^.fielddec>0)
  947.             then fieldpointer^.fieldlen:=fieldpointer^.fieldlen-1;
  948.       end;
  949.       if _in[fieldpointer^.errorind]='1' then begin
  950.          calculatescreenoffset(25,2);
  951.          screenoutput(fieldpointer^.constantdata,
  952.             (length(fieldpointer^.constantdata)),fieldpointer^.bkcolor,
  953.             fieldpointer^.txcolor,fieldpointer^.rvrsimg,fieldpointer^.blink);
  954.           errorsound(450,350);
  955.       end;
  956.       fieldpointer:=fieldpointer^.nextfield;
  957.       zformatname:=fieldpointer^.fmtname;
  958.      until (currentformat^.wformatname<>zformatname) or (fieldpointer=nil);
  959.      end;
  960. end;
  961.  
  962. procedure Help(var fieldpointer:fpointer);  {Help Format Display Routine}
  963.   var
  964.     helpnamez:    fmtnamestring;
  965.     counter:      integer;
  966.     firstformat:  formatpointer absolute format1;
  967.  
  968.   procedure writehelplevel;
  969.     begin
  970.       if helplevel<>0 then begin
  971.          clearbottomline;
  972.          write('Help Level --> ',helplevel:2,' -- Press Any Key To Continue');
  973.          while not keypressed do begin end;
  974.          charin:=readkey;
  975.          if (charin=#0) and (keypressed) then begin
  976.             charin:=readkey;
  977.             if ord(charin)=64 then begin
  978.                if helpnamez<>'        ' then
  979.                   findformat(firstformat,helpnamez);
  980.                help(fieldpointer);
  981.             end;
  982.          end;
  983.       end;
  984.     end;
  985.  
  986.  begin  {Main Line Of HELP Procedure}
  987.   bottomlinebackground:=currentformat^.wbkintcolor;
  988.   bottomlineforeground:=currentformat^.wtxintcolor;
  989.   helpnamez:=currentformat^.whelpname;
  990.   if helpnamez<>'        ' then begin
  991.      counter:=pos(' ',helpnamez);
  992.      helpnamez[0]:=chr(counter-1);
  993.      savescreen(fieldpointer);
  994.      writescreen(helpnamez);
  995.      writehelplevel;
  996.      restorescreen(fieldpointer);
  997.      writehelplevel;
  998.   end
  999.   else begin
  1000.      keyboarderror(7);
  1001.      if helplevel>0 then writehelplevel;
  1002.   end;
  1003.  end;
  1004.  
  1005.  procedure setinputcolor(bkcol,txcol,datalength: byte; datatype:char;
  1006.            blink:byte);
  1007.   var
  1008.    setcolor:    byte;
  1009.    colorindex:  integer;
  1010.    savscroffset: word;
  1011.   begin
  1012.     savscroffset:=displayadapteroffset+currentoffset;
  1013.     setcolor:=backgroundcolortable[txcol + 1] + textcolortable[bkcol + 1];
  1014.     if _in[blink]='1' then setcolor:=setcolor+$80;
  1015.     if datatype='E' then datalength:=datalength+1;
  1016.     for colorindex:=1 to datalength do begin
  1017.        savscroffset:=savscroffset + 2;
  1018.        mem[displayadaptersegment:savscroffset-1]:=setcolor;
  1019.    end;
  1020.   end;
  1021.  
  1022.  procedure readscreen;
  1023.  label fieldloop;
  1024.  var
  1025.   firstformat: formatpointer absolute format1;
  1026.  
  1027.  procedure checktab;
  1028.   var
  1029.    workpointer: fpointer;
  1030.   begin
  1031.    if charvalue=15 then begin
  1032.       workpointer:=fieldpointer^.prvfield;
  1033.       if workpointer=nil then begin
  1034.          workpointer:=fieldpointer^.nextfield;
  1035.          repeat
  1036.            if workpointer<>nil then begin
  1037.               fieldpointer:=workpointer;
  1038.               workpointer:=workpointer^.nextfield;
  1039.            end;
  1040.          until workpointer=nil;
  1041.          fieldpointer:=fieldpointer^.prvfield;
  1042.       end
  1043.       else fieldpointer:=workpointer^.prvfield;
  1044.    end;
  1045.    if (charvalue=9) and (fieldpointer^.nextfield=nil) then fieldpointer:=nil;
  1046.  end;
  1047.  
  1048.  procedure endoffield;
  1049.    begin
  1050.     if insertmodeflag='1' then toggleinsertmode;
  1051.     if (fieldpointer^.datatype='E') and (fieldpointer^.fielddec>0)
  1052.        then fieldpointer^.fieldlen:=fieldpointer^.fieldlen + 1;
  1053.     if (columncount=1) and (charvalue=13) then begin
  1054.        if (fieldpointer^.datatype='C') or (fieldpointer^.datatype='R')
  1055.           then charin:=' '
  1056.        else charin:='0';
  1057.        inpbuffer:='';
  1058.        fillchar(inpbuffer,(fieldpointer^.fieldlen+1),charin);
  1059.        inputbufferlength:=fieldpointer^.fieldlen;
  1060.        inpbuffer[0]:=chr(inputbufferlength);
  1061.     end;
  1062.     if ((columncount>1) and (charvalue=13)) or
  1063.        ((columncount>1) and (charvalue<>13) and
  1064.        (fieldpointer^.datatype<>'C')) then begin
  1065.          columncount:=columncount-1;
  1066.          inpbuffer:=copy(inpbuffer,1,columncount);
  1067.          repeat
  1068.           if columncount<fieldpointer^.fieldlen then begin
  1069.              columncount:=columncount+1;
  1070.              if fieldpointer^.datatype='C' then inpbuffer:=inpbuffer+' '
  1071.              else begin
  1072.                if fieldpointer^.datatype<>'R' then inpbuffer:='0'+inpbuffer
  1073.                else inpbuffer:=' ' + inpbuffer;
  1074.              end;
  1075.           end;
  1076.         until columncount>=fieldpointer^.fieldlen;
  1077.        if (fieldpointer^.datatype = 'S') or (fieldpointer^.datatype = 'E')
  1078.           then begin
  1079.           if ord(charin) = 45 then inpbuffer:=inpbuffer + '-'
  1080.           else inpbuffer:=inpbuffer + ' ';
  1081.        end;
  1082.     end;
  1083.     if (columncount=1) and (fieldpointer^.datatype<>'C') and (charvalue<>13)
  1084.        and (fieldpointer^.datatype<>'R') then begin
  1085.        columncount:=0;
  1086.        repeat
  1087.          columncount:=columncount+1;
  1088.          if inpbuffer[columncount]=' ' then inpbuffer[columncount]:='0';
  1089.        until columncount=fieldpointer^.fieldlen;
  1090.     end;
  1091.     if (fieldpointer^.datatype='E') and (fieldpointer^.fielddec>0)
  1092.        then fieldpointer^.fieldlen:=fieldpointer^.fieldlen-1;
  1093.     checkfield('I',fieldpointer);
  1094.     gotoxy(fieldpointer^.screencol,fieldpointer^.screenrow);
  1095.     textcolor(fieldpointer^.txcolor);
  1096.     textbackground(fieldpointer^.bkcolor);
  1097.     columncount:=0;
  1098.     if (fieldpointer^.datatype<>'C') and
  1099.        ((fieldpointer^.fielddec +1)<fieldpointer^.fieldlen) then begin
  1100.      repeat
  1101.        columncount:=columncount+1;
  1102.        if inpbuffer[columncount]='0' then inpbuffer[columncount]:=' ';
  1103.      until (inpbuffer[columncount]>'0') or
  1104.            (columncount=fieldpointer^.fieldlen-(fieldpointer^.fielddec+1));
  1105.     end;
  1106.     if (fieldpointer^.datatype = 'S') or (fieldpointer^.datatype = 'E')
  1107.        then fieldpointer^.fieldlen:=fieldpointer^.fieldlen + 1;
  1108.     if fieldpointer^.datatype = 'E' then
  1109.        fieldpointer^.fieldlen:=fieldpointer^.fieldlen + 1;
  1110.     write(copy(inpbuffer,1,fieldpointer^.fieldlen));
  1111.     if (fieldpointer^.datatype = 'S') or (fieldpointer^.datatype = 'E')
  1112.        then fieldpointer^.fieldlen:=fieldpointer^.fieldlen-1;
  1113.     if fieldpointer^.datatype = 'E' then
  1114.        fieldpointer^.fieldlen:=fieldpointer^.fieldlen - 1;
  1115.        case charvalue of
  1116.          09: checktab;
  1117.          15: checktab;
  1118.        end;
  1119.    end;
  1120.  
  1121.  procedure endofline;
  1122.    begin
  1123.     scolumn:=1;
  1124.     srow:=srow+1;
  1125.     if srow>24 then begin
  1126.        srow:=24;
  1127.        scolumn:=80;
  1128.        keyboarderror(1);
  1129.     end;
  1130.    end;
  1131.  
  1132.  procedure checkrow;
  1133.    begin
  1134.     if scolumn>80 then begin
  1135.        scolumn:=1;
  1136.        srow:=srow+1;
  1137.     end
  1138.     else begin
  1139.       if scolumn<1 then begin
  1140.          scolumn:=80;
  1141.          srow:=srow-1;
  1142.       end;
  1143.     end;
  1144.    end;
  1145.  
  1146.  procedure cursorerror;
  1147.    begin
  1148.     keyboarderror(2);
  1149.     scolumn:=scolumn-offset;
  1150.     checkrow;
  1151.     gotoxy(scolumn,srow);
  1152.    end;
  1153.  
  1154.  procedure columnadvance;
  1155.     begin
  1156.      scolumn:=scolumn+offset;
  1157.      checkrow;
  1158.      if ((scolumn<fieldpointer^.screencol) and (srow=fieldpointer^.screenrow))
  1159.         or ((scolumn>endcolumn) and (srow=endrow)) then cursorerror
  1160.      else begin
  1161.        if (fieldpointer^.datatype<>'C') and (fieldpointer^.datatype<>'R') and
  1162.           (inpbuffer[columncount]=' ') then inpbuffer[columncount]:='0';
  1163.        columncount:=columncount+offset;
  1164.      end;
  1165.      positioncursor;
  1166.    end;
  1167.  
  1168.  procedure movecursor;
  1169.    begin
  1170.      if (charvalue=75) or (charvalue=8) or (charvalue=67)
  1171.         or (charvalue=92) then offset:=-1;
  1172.      if (charvalue=77) or (charvalue=68) or (charvalue=93) then offset:=1;
  1173.      columnadvance;
  1174.      if (charvalue=92) or (charvalue=93) then columnadvance;
  1175.    end;
  1176.  
  1177.  procedure enterscreen;  {if capslock or commandkey is pressed end screen}
  1178.    begin
  1179.      charvalue:=09;
  1180.      endoffield;
  1181.      if fieldpointer=nil then fieldpointer:=currentformat^.firstfield;
  1182.      repeat
  1183.        if (fieldpointer<>nil) and (fieldpointer^.nextfield<>nil) then
  1184.           fieldpointer:=fieldpointer^.nextfield;
  1185.      until fieldpointer^.nextfield=nil;
  1186.    end;
  1187.  
  1188.  procedure commandkeyproc;
  1189.    var cmdindex: integer;
  1190.    begin
  1191.     { F2--simulated 5250 command key pressed read subsequent command value}
  1192.      while not keypressed do begin end;
  1193.      commandkey:=readkey;
  1194.     {Check For Valid Command Key. Numbers 1-0 and - and =}
  1195.      if ((commandkey >= '0') and (commandkey <= '9'))
  1196.         or (commandkey = '-') or
  1197.         (commandkey = '=') or (ord(commandkey) = 27) then begin
  1198.     {Check if escape pressed if yes then ignore command. Esc is CMD reset }
  1199.         if ord(commandkey)<>27 then begin
  1200.         {setup as though last field had been keyed.}
  1201.           cmdindex:=0;
  1202.     {Check For Valid Commandkey For This Format}
  1203.           repeat
  1204.             cmdindex:=cmdindex + 1;
  1205.           until (commandkey=currentformat^.wcommandkeymask[cmdindex]) or
  1206.                 (cmdindex=13);
  1207.           if cmdindex=13 then begin
  1208.              keyboarderror(8);
  1209.              commandkey:=' ';
  1210.           end
  1211.           else enterscreen;
  1212.         end
  1213.         else begin
  1214.           commandkey:=' ';
  1215.           columnadvance;
  1216.         end;
  1217.      end
  1218.      else begin
  1219.        commandkey:=' ';
  1220.        keyboarderror(10);
  1221.        offset:=0;
  1222.        columnadvance;
  1223.      end;
  1224.  end;
  1225.  
  1226.   procedure Home; {Set Cursor And counters To 1st Field On Screen}
  1227.      begin
  1228.        charvalue:=09;
  1229.        if inputfieldonlyflag<>'1' then endoffield;
  1230.        fieldpointer:=nil;
  1231.        columncount:=1;
  1232.      end;
  1233.  
  1234.   procedure Eraseinput;   {Set Input Field Rewrite Flag & Call Writescreen}
  1235.      begin
  1236.        inputfieldonlyflag:='1';
  1237.        charvalue:=09;
  1238.        endoffield;
  1239.        writescreen(currentformat^.wformatname);
  1240.        Home;
  1241.      end;
  1242.  
  1243.   procedure Printscreen;
  1244.      var
  1245.         bytecount: shortint;
  1246.         linecount: shortint;
  1247.         memloc:    word;
  1248.      begin
  1249.        memloc:=displayadapteroffset;
  1250.        for linecount:=1 to 25 do begin
  1251.            for bytecount:=1 to 80 do begin
  1252.              write(lst,(chr(mem[displayadaptersegment:memloc])));
  1253.              memloc:=memloc + 2;
  1254.            end;
  1255.            write(lst,(chr(13)),(chr(10)));
  1256.        end;
  1257.        write(lst,(chr(12)));
  1258.      end;
  1259.  
  1260.   procedure InsertDeleteWrite;
  1261.     begin
  1262.       gotoxy(scolumn,srow);
  1263.       textcolor(fieldpointer^.bkcolor);
  1264.       textbackground(fieldpointer^.txcolor);
  1265.       write((copy(inpbuffer,columncount,
  1266.             (fieldpointer^.fieldlen+1-columncount))));
  1267.       gotoxy(scolumn,srow);
  1268.     end;
  1269.  
  1270.   procedure Deletechar;
  1271.     begin
  1272.       delete(inpbuffer,columncount,1);
  1273.       inpbuffer:=inpbuffer + ' ';
  1274.       insertdeletewrite;
  1275.     end;
  1276.  
  1277.   procedure Insertchar;
  1278.      var   charwork: string[1];
  1279.      begin
  1280.       if inpbuffer[fieldpointer^.fieldlen]<>' ' then keyboarderror(6)
  1281.       else begin
  1282.         charwork:=charin;
  1283.         inpbuffer:=copy(inpbuffer,1,(fieldpointer^.fieldlen-1));
  1284.         insert(charwork,inpbuffer,columncount);
  1285.         insertdeletewrite;
  1286.         offset:=1;
  1287.         columnadvance;
  1288.       end;
  1289.      end;
  1290.  
  1291.  procedure Escape;
  1292.    var
  1293.      validfunction:   char;
  1294.     { Check Characters Following Escape Character And Select An Action}
  1295.    begin
  1296.      if (charvalue=27) or (charvalue=$00) then begin
  1297.         charin:=readkey;
  1298.         charvalue:=ord(charin);
  1299.      end;
  1300.      validfunction:=' ';
  1301.      case charvalue of
  1302.       15: endoffield;
  1303.       67,68: movecursor;     {cursor left on F9 cursor right on F10}
  1304.       60: commandkeyproc;    {command key request on F2}
  1305.       61: toggleinsertmode;  {F3 Set Insert Mode}
  1306.       62: Home;              {F4 ReSet Cursor}
  1307.       63: Printscreen;       {F5 Print The Screen}
  1308.       64: Help(fieldpointer);{F6 Execute Help Routine}
  1309.       85: Commandkeyproc;    {Shift and F2 same as F2}
  1310.       86: Deletechar;        {Shift F3 Delete Character At Cursor}
  1311.       87: Eraseinput;        {Shift F4 Rewrite Screen Input Fields}
  1312.       92,93: movecursor;     {double speed cursor on shift F9/F10}
  1313.       59,84: systemrequest;  {system request valid for emulator interface only}
  1314.      end;
  1315.    end;
  1316.  
  1317.  procedure managekeyboardstatus;  {check and/or set keyboard status byte}
  1318.    var
  1319.     keyboardstatus:         byte absolute $0040:$0017;
  1320.     capslockstatus:         byte absolute $0040:$0018;
  1321.    begin
  1322.      {check for Alt key pressed and reset insertmode}
  1323.      if (keyboardstatus and $08)<>0 then begin
  1324.         if insertmodeflag='1' then toggleinsertmode;
  1325.         keyboardstatus:=keyboardstatus xor $08;
  1326.      end;
  1327.      {check for capslock and end screen and reset caps state if pressed}
  1328.      if (capslockstatus and $40)<>0 then begin
  1329.         enterscreen;
  1330.         keyboardstatus:=keyboardstatus xor $40;
  1331.      end;
  1332.      {check if numlock pressed. if yes treat as field back (back tab)}
  1333.      if (capslockstatus and $20)<> 0 then begin
  1334.         charvalue:=15;
  1335.         keyboardstatuschange:='1';
  1336.         capslockstatus:=capslockstatus xor $20;
  1337.      end;
  1338.      {check control key if pressed toggle caps lock state and reset ctrl}
  1339.      if ((keyboardstatus and $04)<>0) then
  1340.          keyboardstatus:=keyboardstatus xor $44;
  1341.      {check and ensure numlock is set}
  1342.      if (keyboardstatus and $20)=0 then keyboardstatus:=keyboardstatus xor $20;
  1343.    end;
  1344.  
  1345.  procedure checkforpositioncursor;
  1346.    begin
  1347.      fieldpointer:=currentformat^.firstfield;
  1348.      while (fieldpointer<>nil) and (_in[fieldpointer^.position]<>'1') do
  1349.        fieldpointer:=fieldpointer^.nextfield;
  1350.        if (fieldpointer<>nil) and (_in[fieldpointer^.position]='1') then
  1351.           fieldpointer:=fieldpointer^.prvfield;
  1352.    end;
  1353.  
  1354.  begin  { Main Line Of Read Screen Procedure }
  1355.    if currentformat^.wformatname<>usefmtname then
  1356.       findformat(firstformat,usefmtname);
  1357.    fieldpointer:=nil;
  1358.    checkforpositioncursor;
  1359.    fieldloop: inputfieldonlyflag:=' ';
  1360.    if fieldpointer<>nil then fieldpointer:=fieldpointer^.nextfield
  1361.    else fieldpointer:=currentformat^.firstfield;
  1362.    if fieldpointer<>nil then begin
  1363.       if (fieldpointer^.iotype='O') or (_in[fieldpointer^.protect]='1')
  1364.         then begin
  1365.          if (charvalue=15) or (charvalue=09) then checktab;
  1366.          goto fieldloop;
  1367.       end;
  1368.       charvalue:=0;
  1369.       srow:=fieldpointer^.screenrow;
  1370.       scolumn:=fieldpointer^.screencol;
  1371.       endrow:=fieldpointer^.screenrow;
  1372.       endcolumn:=scolumn+fieldpointer^.fieldlen;
  1373.       if (fieldpointer^.datatype='E') and (fieldpointer^.fielddec>0)
  1374.          then endcolumn:=endcolumn + 1;
  1375.       if endcolumn>80 then begin
  1376.          endcolumn:=endcolumn-80;
  1377.          endrow:=endrow+1;
  1378.       end;
  1379.       columncount:=1;
  1380.       checkfield('U',fieldpointer);
  1381.       calculatescreenoffset(fieldpointer^.screenrow,fieldpointer^.screencol);
  1382.       setinputcolor(fieldpointer^.bkcolor,fieldpointer^.txcolor,
  1383.         fieldpointer^.fieldlen,fieldpointer^.datatype,fieldpointer^.blink);
  1384.       gotoxy(fieldpointer^.screencol,fieldpointer^.screenrow);
  1385.       repeat
  1386.         _in[100]:='0';
  1387.         managekeyboardstatus;
  1388.         if (keypressed) or (keyboardstatuschange='1') then begin
  1389.            if kbderrorflag='1' then begin  {reset default colors after}
  1390.               textcolor(currentformat^.wtxintcolor);
  1391.               {writing error message and }
  1392.               textbackground(currentformat^.wbkintcolor);
  1393.               {clear error message text}
  1394.               clearbottomline;
  1395.               kbderrorflag:=' ';
  1396.             end;
  1397.             textcolor(fieldpointer^.txcolor);
  1398.             textbackground(fieldpointer^.bkcolor);
  1399.             if keypressed then begin
  1400.                charin:=readkey;
  1401.                charvalue:=ord(charin);
  1402.                if fieldpointer^.lowercas<>'Y' then charin:=upcase(charin);
  1403.             end;
  1404.             keyboardstatuschange:=' ';
  1405.             case charvalue of
  1406.                0,27: escape;
  1407.                  08: movecursor;  {cursor left}
  1408.            09,13,15: endoffield;  {horizontal tab,return,tabback/numlock}
  1409.            else
  1410.               if ((fieldpointer^.datatype<>'C') and (charvalue=43)) or
  1411.                  ((fieldpointer^.datatype<>'C') and
  1412.                  (fieldpointer^.datatype<>'N') and (charvalue = 45))
  1413.                  then begin
  1414.                    charvalue:=13;
  1415.                    endoffield;
  1416.                end
  1417.                else begin
  1418.                   gotoxy(scolumn,srow);
  1419.                   if (scolumn=endcolumn) and (srow>=endrow) then begin
  1420.                      keyboarderror(4);
  1421.                      setinputcolor(fieldpointer^.bkcolor,fieldpointer^.txcolor,
  1422.                                    1,fieldpointer^.datatype,100);
  1423.                      write(' ');
  1424.                      gotoxy(scolumn,srow);
  1425.                   end
  1426.                   else begin
  1427.                     if ((fieldpointer^.datatype<>'C') and
  1428.                         (fieldpointer^.datatype<>'R')) and ((charin<'0') or
  1429.                         (charin>'9')) then begin
  1430.                        if (fieldpointer^.datatype='N') or
  1431.                           (fieldpointer^.datatype='S') then _In[100]:='1';
  1432.                        if (fieldpointer^.datatype='E') and (charin<>'.') then
  1433.                           _In[100]:='1';
  1434.                     end;
  1435.                     if _in[100]='1' then keyboarderror(5)
  1436.                     else begin
  1437.                       if insertmodeflag='1' then insertchar
  1438.                       else begin
  1439.                         write(charin);
  1440.                         inpbuffer[columncount]:=charin;
  1441.                         offset:=1;
  1442.                         columnadvance;
  1443.                       end;
  1444.                     end;
  1445.                   end;
  1446.                 end;
  1447.               end;
  1448.            end; {end of if key pressed}
  1449.      until (charvalue=13) or (charvalue=09) or (charvalue=15);
  1450.      charin:=' ';
  1451.      goto fieldloop;
  1452.      end;
  1453.     end;  {end of fields to be processed}
  1454.  
  1455. procedure screenio;
  1456. begin
  1457. writescreen(usezfmtname);
  1458. firsthelpscreen:=nil;
  1459. readscreen(usezfmtname);
  1460. end;
  1461.  
  1462. procedure initialize38;
  1463.  begin
  1464.   if inzscreen<>'1' then begin
  1465.      statusmessage:='Screen File Not Opened. Job Aborted';
  1466.      emulatorstatusmessage;
  1467.      halt
  1468.   end;
  1469.  end;
  1470.  
  1471. procedure copyfield (bytecount,nofield: integer; fieldpointer:fpointer);
  1472.   var
  1473.     index:          integer;
  1474.     inpworkoffset:  integer;
  1475.     numericinput:   char;
  1476.   begin
  1477.     numericinput:=' ';
  1478.     if nofield=1 then begin
  1479.        if fieldpointer^.datatype='E' then begin
  1480.           bytecount:=bytecount + 2;
  1481.           numericinput:='Y';
  1482.        end;
  1483.        if fieldpointer^.datatype='S' then begin
  1484.           bytecount:=bytecount + 1;
  1485.           numericinput:='Y';
  1486.        end;
  1487.        if fieldpointer^.datatype='N' then numericinput:='Y';
  1488.     end;
  1489.     inpworkoffset:=inpbufferoffset;
  1490.     currentoffset:=(currentoffset + screenoffset) - 1;
  1491.     for index:=1 to bytecount do begin
  1492.       mem[inpbuffersegment:inpworkoffset]:=
  1493.       mem[em5250segment:(ebcdictableoffset + mem[em5250segment:currentoffset +
  1494.       index])];
  1495.       if mem[inpbuffersegment:inpworkoffset]=$FF then
  1496.       mem[inpbuffersegment:inpworkoffset]:=$20;
  1497.       if (numericinput='Y') and (mem[inpbuffersegment:inpworkoffset]=$20) then
  1498.          mem[inpbuffersegment:inpworkoffset]:=$30;
  1499.       inpworkoffset:=inpworkoffset + 1;
  1500.     end;
  1501.     currentoffset:=(currentoffset - screenoffset) + 1;
  1502.     inpbuffer[0]:=chr(bytecount);
  1503.   end;
  1504.  
  1505. procedure select38format (selectrow,selectcolumn,idlen: shortint);
  1506.  
  1507.   var
  1508.    blanks:           string[8];
  1509.    firstformat:      formatpointer absolute format1;
  1510.    errorcount:       integer;
  1511.    dummyptr:         fpointer;
  1512.   begin
  1513.     blanks:='        ';
  1514.     blanks[0]:=chr(idlen);
  1515.     if inz38flag<>'1' then initialize38; {initialize emulator card variables}
  1516.     checkinputinhibit;                   {check emulator input inhibited ind.}
  1517.     calculateoffset(selectrow,selectcolumn); {calculate offset to screen id.}
  1518.     copyfield(idlen,0,dummyptr);         {copy in emulator screen id }
  1519.     findformat(firstformat,(copy(inpbuffer,1,idlen)));
  1520.     if (currentformat=nil) or (copy(inpbuffer,1,idlen)=blanks) then begin
  1521.        statusmessage:='PC To S/38 I/O Error - No Format Match';
  1522.        for errorcount:=1 to 25 do emulatorstatusmessage;
  1523.        halt;
  1524.     end;
  1525.   end;
  1526.  
  1527. procedure setio (setioflag: char; fieldpointer: fpointer);
  1528.    begin
  1529.      calculateoffset(fieldpointer^.screenrow,fieldpointer^.screencol);
  1530.      if setioflag='I' then copyfield(fieldpointer^.fieldlen,1,fieldpointer);
  1531.      checkfield(setioflag,fieldpointer);
  1532.    end;
  1533.  
  1534. procedure read38;
  1535.  {determine s38 format id, retrieve format & read variables}
  1536.   var
  1537.     firstformat:    formatpointer absolute format1;
  1538.   begin
  1539.     currentformat:=firstformat;
  1540.     select38format(idrow,idcol,idlen); {locate PC format}
  1541.     fieldpointer:=currentformat^.firstfield;
  1542.     repeat
  1543.      if fieldpointer^.iotype<>'I' then setio('I',fieldpointer);
  1544.      fieldpointer:=fieldpointer^.nextfield;
  1545.     until fieldpointer=nil;
  1546.   end;
  1547.  
  1548. procedure sendcommandkey;
  1549.   var
  1550.     saveinteger,index: integer;
  1551.     savebyte: byte;
  1552.   begin
  1553.     sendfieldexit(commandcode);
  1554.     case commandkeyx of
  1555.      '0': saveinteger:=10;
  1556.      '-': saveinteger:=11;
  1557.      '=': saveinteger:=12;
  1558.      else val(commandkeyx,saveinteger,index);
  1559.      end;
  1560.      savebyte:=saveinteger + $30;
  1561.      sendfieldexit(savebyte);
  1562.   end;
  1563.  
  1564. procedure write38;
  1565.   {write variables to emulator screen buffer and send the enter scan code}
  1566.  var
  1567.   savebyte:      byte;
  1568.   saveinteger:   integer;
  1569.   signsave:      char;
  1570.   index:         integer;
  1571.   teststring:    string[10];
  1572.   datatype:      char;
  1573.  begin
  1574.   select38format (idrow,idcol,idlen);
  1575.   fieldpointer:=currentformat^.firstfield;
  1576.   sendfieldexit(fieldadvancecode); {miss position 5250 cursor so}
  1577.   sendfieldexit(cursorrightcode);  {that home key will work }
  1578.   sendfieldexit(homecursorcode); {ensure 5250 cursor is in 1st Field}
  1579.   repeat
  1580.     if fieldpointer^.iotype<>'O' then begin
  1581.       datatype:=fieldpointer^.datatype;
  1582.       setio ('U',fieldpointer);
  1583.       signsave:=' ';
  1584.       if (datatype='N') or (datatype='S') or (datatype='E') then begin
  1585.         if (datatype<>'N') then begin
  1586.           if inpbuffer[(length(inpbuffer))]='-' then begin
  1587.              signsave:='-';
  1588.              inpbuffer:=copy(inpbuffer,1,(length(inpbuffer)-1));
  1589.           end;
  1590.         end;
  1591.         for index:=1 to (length(inpbuffer)) do
  1592.           if inpbuffer[index]=' ' then inpbuffer[index]:='0';
  1593.         if (datatype='N') and (fieldpointer^.fielddec>0) then begin
  1594.           saveinteger:=fieldpointer^.fieldlen-fieldpointer^.fielddec;
  1595.           teststring:=copy(inpbuffer,(saveinteger + 1),fieldpointer^.fielddec);
  1596.           inpbuffer:=(copy(inpbuffer,1,(saveinteger))) + '.';
  1597.           inpbuffer:=inpbuffer + teststring;
  1598.         end;
  1599.       end;
  1600.       calculateoffset(fieldpointer^.screenrow,fieldpointer^.screencol);
  1601.       for index:=1 to length(inpbuffer) do begin
  1602.          savebyte:=ord(inpbuffer[index]) + 1;
  1603.          if signsave<>'-' then begin
  1604.             mem[em5250segment:(screenoffset + currentoffset)]:=
  1605.             asciitranslatetable[savebyte];
  1606.             currentoffset:=currentoffset + 1;
  1607.          end
  1608.          else sendfieldexit(scancode5250table[savebyte]);
  1609.       end;
  1610.       if block38=' ' then begin
  1611.         if signsave<>'-' then sendfieldexit(fieldadvancecode)
  1612.         else sendfieldexit(fieldminuscode);
  1613.       end;
  1614.     end;
  1615.     fieldpointer:=fieldpointer^.nextfield;
  1616.   until fieldpointer=nil;
  1617.   while mem[em5250segment:keyo]<>$00 do begin end; {wait for keyboard available}
  1618.   if commandkey=' ' then sendfieldexit(entercode)
  1619.   else sendcommandkey(commandkey);
  1620.  end;
  1621.  
  1622.  procedure copyscreen;
  1623.  {copies emulated 5250 screen buffer character for character from
  1624.  the starting row/column through and including the ending row column
  1625.  attribute bytes in the emulated screen are checked for and dropped}
  1626.  var
  1627.   endaddress:    word;
  1628.   bufferindex:   integer;
  1629.   bytecount:     integer;
  1630.   dummyptr:      fpointer;
  1631.  const
  1632.   screensegment: word = $B000;
  1633.   coloroffset:   word = $8000;
  1634.  begin
  1635.    coloroffset:=displayadapteroffset;
  1636.    if inz38flag<>'1' then initialize38;
  1637.    checkinputinhibit;
  1638.    calculateoffset(endrow,endcolumn);
  1639.    endaddress:=currentoffset;
  1640.    calculateoffset(startrow,startcolumn);
  1641.    textcolor(15);
  1642.    textbackground(1);
  1643.    coloroffset:=currentoffset + currentoffset + coloroffset;
  1644.    bytecount:=(endaddress-currentoffset) + 1;
  1645.    if bytecount>80 then bytecount:=80;
  1646.    repeat
  1647.      copyfield(bytecount,0,dummyptr);
  1648.      for bufferindex:=1 to bytecount do begin
  1649.        mem[screensegment:coloroffset]:=
  1650.        mem[inpbuffersegment:inpbufferoffset + (bufferindex-1)];
  1651.        coloroffset:=coloroffset + 2;
  1652.      end;
  1653.      currentoffset:=currentoffset + bytecount;
  1654.    until currentoffset>=endaddress;
  1655.    coloroffset:=displayadapteroffset;
  1656.  end;
  1657.  
  1658. procedure check38;
  1659.  var endrow,endcol: shortint;
  1660.  begin
  1661.    endrow:=startrow;
  1662.    endcol:=startcol+lengthx-1;
  1663.    if endcol>80 then begin
  1664.       endrow:=endrow + 1;
  1665.       endcol:=endcol-80;
  1666.    end;
  1667.    copyscreen(startrow,startcol,endrow,endcol);
  1668.    rtnformat:=copy(inpbuffer,1,lengthx);
  1669.  end;
  1670.  
  1671. begin
  1672.   inpbuffersegment:=seg(inpbuffer);
  1673.   inpbufferoffset:=ofs(inpbuffer) + 1;
  1674.   inz38flag:='1';
  1675.   em5250segment:=memw[0000:$0036];
  1676.   screenoffset:=memw[em5250segment:$0146];
  1677.   ebcdictableoffset:=memw[em5250segment:$0140];
  1678.   fillchar(blanktest,81,' ');
  1679.   blanktest[0]:=chr(80);
  1680.   while mem[em5250segment:systemavailable]=0 do begin
  1681.     statusmessage:='Waiting For System Available';
  1682.     emulatorstatusmessage;
  1683.   end;
  1684. end.
  1685.